Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/pcscheme/geneva/sources.exe/SOURCES/LISP/IO.LSP

Text File | 1993-10-25 | 18.9 KB | 497 lines

;; PC Scheme Common Lisp Compatibility Package
;;
;; (c) Copyright 1990 Carl W. Hoffman.  All rights reserved.
;;
;; This file may be freely copied, distributed, or modified for non-commercial
;; use provided that this copyright notice is not removed.  For further
;; information about other utilities for Common Lisp or Scheme, contact the
;; following address:
;;
;;   Carl W. Hoffman, 363 Marlborough Street, Boston, MA 02115, U.S.A.
;;   Internet: [e-mail]    CompuServe: 76416,3365    Fax: [phone]

;; Streams and I/O

(defun-clcp display-substring (raw-stream string start end)
  (if (and (null start) (null end))
      (display string raw-stream)
      (progn
        (setq start (or start 0))
        (setq end (or end (length string)))
        (do ((i start (1+ i)))
            ((= i end))
          (scheme-write-char (char string i) raw-stream)))))

(defun-clcp make-encapsulated-input-stream (raw-stream)
  (let ((unch nil))
    (lambda (op . args)
      (case op
        (direction
          'input)
        (close
          (close-input-port raw-stream))
        (read-char
          (if unch
              (prog1 unch (setq unch nil))
              (scheme-read-char raw-stream)))
        (un-read-char
          (if unch
              (error "Attempt to UNREAD-CHAR twice on the stream ~S."
                     raw-stream))
          (setq unch (car args)))
        (peek-char
          (or unch
              (progn (setq unch (scheme-read-char raw-stream))
                     unch)))))))

(defun-clcp make-encapsulated-output-stream (raw-stream)
  (lambda (op . args)
    (case op
      (direction
        'output)
      (close
        (close-output-port raw-stream))
      (fresh-line
        (scheme-fresh-line raw-stream))
      (write-char
        (scheme-write-char (car args) raw-stream))
      (write-string
        (apply display-substring raw-stream args)))))

(defun make-string-input-stream (string)
  (make-encapsulated-input-stream (open-input-string string)))

;; This could make effective use of resources.

(defun make-string-output-stream ()
  (let ((buffer (make-string 50))
        (index 0))
    (flet ((assure-buffer-size (n)
             (let* ((buffer-size (string-length buffer))
                    (new-size (+ index n)))
               (when (> new-size buffer-size)
                 (let ((new-buffer (make-string (* 2 new-size))))
                   (%%replace-string new-buffer buffer 0 0 buffer-size)
                   (setq buffer new-buffer))))))
      (lambda (op . args)
        (case op
          (direction
            'output)
          (close
            (if (= index 0)
                ""
                (let ((final-string (make-string index)))
                  (%%replace-string final-string buffer 0 0 index)
                  (setq index 0)
                  final-string)))
          (fresh-line
            (when (and (> index 0)
                       (not (char= (char buffer (1- index)) #\newline)))
              (assure-buffer-size 1)
              (string-set! buffer index #\newline)
              (incf index)
              t))
          (write-char
            (assure-buffer-size 1)
            (string-set! buffer index (car args))
            (incf index))
          (write-string
            (let* ((output-string (first args))
                   (start         (or (second args) 0))
                   (end           (or (third args) (length output-string)))
                   (output-size   (- end start)))
              (assure-buffer-size output-size)
              (%%replace-string buffer output-string index start output-size)
              (incf index output-size))))))))

(defmacro with-open-stream (stream-description &body body)
  (unless (and (listp stream-description)
               (cdr stream-description)
               (null (cddr stream-description)))
    (error "The first argument to WITH-OPEN-STREAM must be ~
            a pattern of the form (VAR STREAM)."))
  (let ((stream-var (car stream-description)))
    (unless (symbolp stream-var)
      (error "The stream variable argument to WITH-OPEN-STREAM ~
              is not a symbol."))
    (if (member stream-var '(*standard-input* standard-output*))
        `(let ((.temp. ,stream-var))
           (setq ,stream-var ,(cadr stream-description))
           (prog1 (progn . ,body)
                  (close ,stream-var)
                  (setq ,stream-var .temp.)))
        `(let ((,stream-var ,(cadr stream-description)))
           (prog1 (progn . ,body)
                  (close ,stream-var))))))

(defmacro with-input-from-string (stream-description &body body)
  (unless (and (listp stream-description)
               (cdr stream-description)
               (null (cddr stream-description)))
    (error "The first argument to WITH-INPUT-FROM-STRING must be ~
            a pattern of the form (VAR STRING)."))
  (let ((stream-var (car stream-description))
        (string-form (cadr stream-description)))
    (unless (symbolp stream-var)
      (error "The stream variable argument to WITH-INPUT-FROM-STRING ~
              is not a symbol."))
    `(with-open-stream (,stream-var (make-string-input-stream ,string-form))
       . ,body)))

(defmacro with-output-to-string (stream-description &body body)
  (unless (and (listp stream-description)
               (or (null (cdr stream-description))
                   (null (cddr stream-description))))
    (error "The first argument to WITH-OUTPUT-TO-STRING must be ~
            a pattern of the form (VAR) or (VAR STRING)."))
  (unless (null (cdr stream-description))
    (error "The two-argument form of WITH-OUTPUT-TO-STRING is not ~
            yet supported."))
  (let ((stream-var (car stream-description)))
    (unless (symbolp stream-var)
      (error "The stream variable argument to WITH-OUTPUT-TO-STRING ~
              is not a symbol."))
    `(with-open-stream (,stream-var (make-string-output-stream))
       ,@body
       (get-output-stream-string ,stream-var))))

(defvar *standard-input*  (current-input-port))
(defvar *standard-output* (current-output-port))
(defvar *error-output*    (current-output-port))

(defvar *query-io*    'console)
(defvar *debug-io*    'console)
(defvar *terminal-io* 'console)

(defun streamp (object)
  (or (null object)
      (port? object)
      (and (procedure? object)
           (funcall object 'direction)
           t)))

(defun check-stream (procedure stream)
  (unless (streamp stream)
    (error "The argument to ~A, ~S, is not a stream"
           procedure stream)))

;; CL requires that the arguments to INPUT-STREAM-P and OUTPUT-STREAM-P
;; be streams.

(defun input-stream-p (stream)
  (check-stream 'input-stream-p stream)
  (or (null stream)
      (input-port? stream)
      (and (procedure? stream)
           (memq (funcall stream 'direction) '(input bidirectional))
           t)))

(defun output-stream-p (stream)
  (check-stream 'output-stream-p stream)
  (or (null stream)
      (output-port? stream)
      (and (procedure? stream)
           (memq (funcall stream 'direction) '(output bidirectional))
           t)))

(defun-clcp check-input-stream (procedure stream &optional cl-only?)
  (unless (and (streamp stream) (input-stream-p stream))
    (error "The argument to ~A, ~S, is not an input stream."
           procedure stream))
  (when (and cl-only? (not (procedure? stream)))
    (error "The stream ~S does not support the ~A operation."
           stream procedure)))

(defun-clcp check-output-stream (procedure stream &optional cl-only?)
  (unless (and (streamp stream) (output-stream-p stream))
    (error "The argument to ~A, ~S, is not an output stream."
           procedure stream))
  (when (and cl-only? (not (procedure? stream)))
    (error "The stream ~S does not support the ~A operation."
           stream procedure)))

(defun close (stream)
  (check-stream 'close stream)
  (cond ((input-port? stream)
         (close-input-port stream))
        ((output-port? stream)
         (close-output-port stream))
        (else
         (funcall stream 'close))))

;; It might be better to use a different message name than CLOSE for this
;; function.  STRING-OUTPUT-STREAM can just ignore CLOSE, since it might be
;; sent from places we don't expect it.

(defun get-output-stream-string (string-output-stream)
  (check-output-stream 'get-output-stream-string string-output-stream t)
  (funcall string-output-stream 'close))

(defun check-eof (thing input-stream eof-error-p eof-value)
  (cond ((not (eof-object? thing))
         thing)
        (eof-error-p
          (error "EOF reached on the input stream ~S." input-stream))
        (t
          eof-value)))

(defun read-char (&optional input-stream (eof-error-p t) eof-value)
  (unless input-stream
    (setq input-stream *standard-input*))
  (check-input-stream 'read-char input-stream)
  (check-eof
    (if (input-port? input-stream)
        (scheme-read-char input-stream)
        (funcall input-stream 'read-char))
    input-stream eof-error-p eof-value))

(defun un-read-char (char &optional input-stream)
  (unless input-stream
    (setq input-stream *standard-input*))
  (check-type char character)
  (check-input-stream 'un-read-char input-stream t)
  (funcall input-stream 'un-read-char char))

(defun peek-char (&optional peek-type input-stream (eof-error-p t) eof-value)
  (unless input-stream
    (setq input-stream *standard-input*))
  (check-input-stream 'peek-char input-stream t)
  (check-eof
    (cond ((or (eq peek-type nil) (eq peek-type 'nil))
           (funcall input-stream 'peek-char))
          ((or (eq peek-type t) (eq peek-type 't))
           (do ((ch (funcall input-stream 'peek-char)
                    (funcall input-stream 'peek-char)))
               ((or (eof-object? ch)
                    (not (member ch '(#\space #\tab #\newline))))
                ch)
             (funcall input-stream 'read-char))))
    input-stream eof-error-p eof-value))

;; SCHEME-READ accepts an arbitrary number of arguments, but apparently only
;; looks at the first one.  I guess somebody forgot to check for too many
;; arguments.

;; READ is compatible with Scheme when called with fewer than two arguments.
;; When called with two or more arguments, it is compatible with Common Lisp.
;; It can't be made completely compatible with Common Lisp since that breaks
;; PC Scheme.

(defun read (&optional input-stream (eof-error-p 'scheme) eof-value)
  (if (eq eof-error-p 'scheme)
      (scheme-read input-stream)
      (progn
        (unless input-stream
          (setq input-stream *standard-input*))
        (check-eof (scheme-read input-stream)
                   input-stream eof-error-p eof-value))))

(defun fresh-line (&optional output-stream)
  (unless output-stream
    (setq output-stream *standard-output*))
  (check-output-stream 'fresh-line output-stream)
  (if (output-port? output-stream)
      (scheme-fresh-line output-stream)
      (funcall output-stream 'fresh-line)))

(defun terpri (&optional output-stream)
  (unless output-stream
    (setq output-stream *standard-output*))
  (check-output-stream 'terpri output-stream)
  (if (output-port? output-stream)
      (newline output-stream)
      (funcall output-stream 'write-char #\newline))
  nil)

(defun write-char (char &optional stream)
  (check-type char character)
  (check-output-stream 'write-char stream)
  (if (or (null stream) (output-port? stream))
      (scheme-write-char char stream)
      (funcall stream 'write-char char))
  char)

(defun-clcp write-string-internal (string stream start end)
  (check-type string string)
  (check-output-stream 'write-string stream)
  (if (or (null stream) (output-port? stream))
      (display-substring stream string start end)
      (funcall stream 'write-string string start end))
  string)

(defmacro write-string (string &optional stream &rest keywords)
  `(write-string-internal ,string ,stream .
                          ,(parse-keywords '(:start :end) keywords)))

(defun write-line (string &optional stream)
  (check-type string string)
  (write-string string stream)
  (terpri stream)
  string)

(defun-clcp %%write (object stream escape pretty)
  (unless stream
    (setq stream (current-output-port)))
  (if pretty
      ;; Warning! This won't work for CL streams.
      (pp object stream)
      (let ((class (%%structurep object)))
        (cond

          (class
            (let ((print-function (eval (get class 'print-function))))
              (if print-function
                  (fluid-let ((*print-escape* escape))
                    (print-function object stream nil))
                  (begin
                    (write-string "#<" stream)
                    (write-string (symbol-name class) stream)
                    (write-string ">" stream)))))

          ;; Deal with composite objects first, since it may be necessarily
          ;; to recursively invoke WRITE.

          ((vectorp object)
           (write-string "#(" stream)
           (dotimes (i (vector-length object))
             (unless (zerop i)
               (write-char #\space stream))
             (%%write (vector-ref object i) stream escape pretty))
           (write-string ")" stream))

          ((consp object)
           (write-char #\( stream)
           (do ((l object (cdr l)))
               ((null l))
             (unless (consp l)
               (write-string " . " stream)
               (%%write l stream escape pretty)
               (return nil))
             (unless (eq l object)
               (write-char #\space stream))
             (%%write (car l) stream escape pretty))
           (write-char #\) stream))

          ;; From this point onward, the CLCP version of WRITE should
          ;; output exactly the same characters as the Scheme version,
          ;; however CL streams are supported.

          ;; At some point in the future, we may require all streams
          ;; to be encapsulated, in which case the following clause
          ;; should be removed.

          ((output-port? stream)
           (funcall (if escape scheme-write display) object stream))

          ((null object)
           (write-string "()" stream))
          ((integerp object)
           (write-string (number->string object '(int (radix d s))) stream))
          ((floatp object)
           (write-string (number->string object '(flo h)) stream))

          ((eof-object? object)
           (write-string "#<Scheme EOF>" stream))
          ((input-port? object)
           (write-string "#<Scheme input port>" stream))
          ((output-port? object)
           (write-string "#<Scheme output port>" stream))

          (else

            (flet ((write-quoted-string (string quote-char)
                     (write-char quote-char stream)
                     (dotimes (i (string-length string))
                       (let ((char (char string i)))
                         (when (or (char= char #\\) (char= char quote-char))
                           (write-char #\\ stream))
                         (write-char char stream)))
                     (write-char quote-char stream)))

              (cond ((stringp object)
                     (if (not escape)
                         (write-string object stream)
                         (write-quoted-string object #\")))

                    ((symbolp object)
                     (let* ((string (symbol->string object))
                            (length (string-length string)))
                       (cond ((not escape)
                              (write-string string stream))
                             ((dotimes (i length)
                                (let ((char (char string i)))
                                  (when (or (char-whitespace? char)
                                            (char-lower-case? char))
                                    (return t))))
                              (write-quoted-string string #\|))
                             (else
                               (dotimes (i length)
                                 (let ((char (char string i)))
                                   (when (or (char= char #\\) (char= char #\|))
                                     (write-char #\\ stream))
                                   (write-char char stream)))))))

                    (else
                      (write-string "#<CLCP unprintable>" stream))))))))
  object)

;; The default value of :ESCAPE should be the value of *PRINT-ESCAPE*.
;; For now, just make it be T.

;; However, must extend PARSE-KEYWORDS to indicate when a keyword is not
;; present so that the default value can be used.  For now, just kludge it.

(defmacro write (object &rest keywords)
  (let* ((parsed (parse-keywords '(:stream :escape :pretty) keywords)))
    `(%%write ,object
              ,(first parsed)
              ,(if (member ':escape keywords) (second parsed) t)
              ,(third parsed))))

(defun read-from-string-internal (string eof-error-p eof-value start end)
  (let ((length (length string)))
    (when (or (and start (> start 0))
              (and end (< end length)))
      (setq string (subseq string (or start 0) (or end length)))))
  (read (open-input-string string) eof-error-p eof-value))

(defmacro read-from-string (string &optional (eof-error-p t) eof-value
                                   &rest keywords)
  `(read-from-string-internal ,string ,eof-error-p ,eof-value .
                              ,(parse-keywords '(:start :end) keywords)))

;; File streams

(define :direction ':direction)
(define :input     ':input)
(define :output    ':output)

(defmacro with-open-file (descriptor &body body)
  (let ((stream    (first descriptor))
        (file      (second descriptor))
        (flag      (third descriptor))
        (direction (fourth descriptor)))
    (cond ((null (cddr descriptor))
           (setq flag :direction)
           (setq direction :input))
          ((not (eq flag :direction))
           (error "Unknown flag" flag))
          ((not (member direction '(:input :output)))
           (error "Unknown direction" direction)))
    (cond ((eq stream '*standard-input*)
           (unless (eq direction :input)
             (error "Can't bind *STANDARD-INPUT* to a file being ~
                     opened for output."))
           `(with-input-from-file  ,file (lambda () . ,body)))
          ((eq stream '*standard-output*)
           (unless (eq direction :output)
             (error "Can't bind *STANDARD-OUTPUT* to a file being ~
                     opened for input."))
           `(with-output-to-file   ,file (lambda () . ,body)))
          ((eq direction :input)
           `(call-with-input-file  ,file (lambda (,stream) . ,body)))
          ((eq direction :output)
           `(call-with-output-file ,file (lambda (,stream) . ,body)))
          (else
           (error "Shouldn't get here")))))